home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
archiver
/
ldiff12s.zip
/
LDEXTR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-07-15
|
4KB
|
148 lines
(*---------------------------------------------------------------------------*)
(*LDExtr.pas ë≡ôÇÅêù¥ü@ü@ ü@ (C) ÄOû╪ÿaòF NIFTY SDR SDI00147 1989/7/1 *)
(*$B-,F-,I-,N- *)
(*---------------------------------------------------------------------------*)
UNIT LDExtr;
INTERFACE
USES
Dos,
MyType,
MyTool,
LDVari,
LDProc;
PROCEDURE ExtrJob;
IMPLEMENTATION
{$L LDD }
FUNCTION DeCode(inf,outf:WORD;size:LONGINT;flg:WORD):BOOLEAN;EXTERNAL;
FUNCTION GetHdrVer(s:STR3):BYTE;
BEGIN
GetHdrVer:=0;
IF (s[2]='s') AND (s[3]='-') THEN GetHdrVer:=1 ELSE
IF s[2] IN ['0'..'9'] THEN
IF s[3] IN ['0'..'9']
THEN GetHdrVer:=(ORD(s[2])-ORD('0'))*10+ORD(s[3])-ORD('0')
ELSE GetHdrVer:=ORD(s[2])-ORD('0');
END;
PROCEDURE SetLzdHdr;
VAR
ep : WORD;
d : DirStr;
n : NameStr;
e : ExtStr;
BEGIN
IF NOT ReadHdr(LzdFVar) THEN Error(LzdFName,IsNotLzdErMsg);
WITH lh1,lh2,lh3,LzdFN DO BEGIN
FSplit(LFName,d,n,e);
CASE LHdrSID[1] OF
'H','h' : Error(LzdFName,LzhErMsg);
'Z','z' : IF (LHdrSID[2]<>'6') AND (LHdrSID[3]<>'-') THEN
Error(LzdFName,LzsErMsg);
'D','d' : ;
ELSE
Error(LzdFName,UnknownErMsg);
END;
IF GetHdrVer(LHdrSID)<>6 THEN Error('',NewVerErMsg);
NewName := n+e;
IF LHdrID[2]='L' THEN BEGIN
NewCrc :=LCRC;
NewAttr :=LAttr;
OldCrc :=LOldCrc;
OldFSize:=LOldFSize;
OldName :=LOldName;
EI :=LEI;
EJ :=LEJ;
CTYPE :=LCTYPE;END
ELSE BEGIN
ep:=SizeOf(LHdr)-255+Length(LFName);
NewAttr:=LCRC;
NewCrc :=buf1[ep]+buf1[ep+1]*256;
OldCrc :=buf1[ep+2]+buf2[ep+3]*256;
Move(buf1[ep+4],OldFSize,4);
Move(buf1[ep+8],OldName,Succ(buf1[ep+8]));
EI :=18;
EJ :=14;
CTYPE :='N';END;
NewFSize :=LFSize;
NewTime :=LTime;
NewSize :=LSize;
NewHSize :=LNum+2;
END;
END;
PROCEDURE ExtrJob;
VAR
d : DirStr;
n : NameStr;
e : ExtStr;
fs : LONGINT;
BEGIN
IF NOT BlkOpen(LzdFVar,'I',LzdFName) THEN Error(LzdFName,CannotFoundErMsg);
IF NOT ChkHdr(LzdFVar) THEN BEGIN
IF NOT SkipArcHdr(LzdFVar) THEN Error(LzdFName,IsNotLzdErMsg);
END;
SetLzdHdr;
WITH LzdFN DO BEGIN
IF NOT( ((EI=18) AND (EJ=14)) OR ((EI=16) AND (EJ=16)) ) THEN
Error('',Wait150Msg);
IF (CTYPE<>'N') THEN Error('',Wait200Msg);
IF NewFName='' THEN NewFName:=NewName;
IF OldFName='' THEN BEGIN
IF BlkOpen(OldFVar,'I',OldName) THEN BEGIN
OldFName:=OldName;BlkClose(OldFVar);END
ELSE BEGIN
OldFName:=NewFName;
END;END;
ReadDic(fs);
IF OldFSize<>fs THEN Error(OldFName,OldFSizeErMsg);
IF OldCrc<>CRC THEN Error(OldFName,OldCrcErMsg);
WriteLn(OUTF,MEG(OldFileMsg)+OldFName+MEG(OldFileOKMsg));
IF FExist(NewFName)<>0 THEN BEGIN
IF NOT YesNo(NewFName+' '+MEG(OverWriteMsg)) THEN Halt(2);
FSplit(NewFName,d,n,e);
IF FExist(d+OldName)=0 THEN FReName(NewFName,d+OldName);
END;
IF NOT BlkOpen(NewFVar,'O',NewFName) THEN
Error(NewFName,CantCreateErMsg);
WriteLn(OUTF,MEG(CreatingMsg)+' '+NewFName+' '+MEG(FromMsg)+' '+
OldFName+' '+MEG(WithMsg)+' '+LzdFName);
CRC:=0;
IF NOT DeCode(LzdFVar.Handle,NewFVar.Handle,NewSize,EI) THEN
Error(LzdFName,DecodeErMsg);
WriteLn(OUTF);
IF CRC<>NewCrc THEN
MsgLn(MEG(FatalErMsg))
ELSE BEGIN
Write(MEG(ExtractOKMsg)+' '+NewFVar.Path);
IF Length(NewFVar.Path)=3
THEN WriteLn(AscZ(NewFVar.Name))
ELSE WriteLn(PathDelim+AscZ(NewFVar.Name));END;
IF (CRC=NewCRC) OR (CMD='T') THEN BEGIN
SetBTime(NewFVar,NewTime);
BlkClose(NewFVar);
SetBAttr(NewFVar,NewAttr);END
ELSE BEGIN
BlkClose(NewFVar);
BlkErase(NewFVar);
END;
END;
BlkClose(LzdFVar);
END;
END.